# Import data
daily_trips <- dbGetQuery(con, "SELECT * FROM analysis.daily_trips")
# Clean and tidy
daily_trips <- daily_trips %>%
mutate("year" = year(date),
"day" = yday(date),
"date_x" = date %>%
as.character(.) %>%
str_replace("^\\d{4}","2000") %>%
as_date(.),
"weekday" = wday(date, label = TRUE),
"trips" = as.numeric(trips))
# Plot information
daily_trips_plot_title <- daily_trips %>%
group_by(year) %>%
summarize(trips = sum(trips)) %>%
pivot_wider(everything(), names_from = "year", values_from = "trips") %>%
mutate("change" = `2020`-`2019`,
"change_pct" = (change/`2019`),
"title_text" = paste0(as.character(comma(-change)),
" (", percent(change_pct), ")"))
# Daily trips YoY plot
gg_daily_trips <- daily_trips %>%
group_by(year) %>%
arrange(date_x) %>%
mutate(trips_agg = cumsum(trips)) %>%
ggplot(aes(x = date_x, y = trips_agg, color = as.character(year))) +
geom_line(size = 1.5) +
geom_vline(xintercept = as.numeric(as.Date("2000-03-21")),
linetype = 4, color = "black", size = 1) +
scale_x_date(date_breaks = "1 month",
date_labels = "%b-%d") +
scale_y_continuous(labels = comma,
limits = c(0, NA)) +
labs(title = paste0("Compared to the same period in 2019 (1/1-9/30),\nrideshare trips have decreased by ",
daily_trips_plot_title$title_text, " in 2020"),
x = "Day of the Year", y = "Aggregate Trips",
color = "Year") +
scale_color_ipsum() +
theme_ipsum()
# Interactive plot
ggplotly(gg_daily_trips)
Prior to Governor Pritzker’s Stay-at-Home Order going into effect on March 21st, trips were already down by about 7 percent year-over-year. However, the bulk of the decline in rideshare occurred over the spring and summer. From late March to October, only 17 million rideshare trips were taken in Chicago, a 71 percent decline compared to 2019.
# Pre/Post COVID table
daily_trips %>%
mutate("covid_group" = ifelse(date_x >= "2000-03-21",
"Post-COVID",
"Pre-COVID")) %>%
mutate("covid_group" = factor(covid_group,
levels = c("Pre-COVID",
"Post-COVID"))) %>%
group_by(covid_group, year) %>%
summarize(trips = sum(trips)) %>%
ungroup() %>%
pivot_wider(names_from = "year",
values_from = "trips") %>%
adorn_totals("row") %>%
mutate("change" = `2020`-`2019`,
"change_pct" = (change/`2019`)) %>%
mutate(across(c(`2019`, `2020`, change), comma),
"change_pct" = percent(change_pct)) %>%
select("Period" = covid_group, `2019`, `2020`,
"Change" = change, "Change (%)" = change_pct) %>%
kbl() %>%
row_spec(3, bold = TRUE) %>%
kable_styling(bootstrap_options = c("striped", "hover",
"condensed", "responsive"))
| Period | 2019 | 2020 | Change | Change (%) |
|---|---|---|---|---|
| Pre-COVID | 24,413,752 | 22,610,225 | -1,803,527 | -7% |
| Post-COVID | 59,148,536 | 17,161,435 | -41,987,101 | -71% |
| Total | 83,562,288 | 39,771,660 | -43,790,628 | -52% |
# Import data
monthly_trips <- dbGetQuery(con, "SELECT * FROM analysis.monthly_trips")
# Clean and tidy
monthly_trips <- monthly_trips %>%
mutate("year" = year(month),
"date_x" = floor_date(month, unit = "month") %>%
as.character(.) %>%
str_replace("^\\d{4}","2000") %>%
as_date(.),
"month" = month(month, label = TRUE, abbr = TRUE),
"trips" = as.numeric(trips))
Taking a step back to examine trips per month, rideshare trips reached a low of 1.5 million in April. While trips rebounded in the following months, they have hovered around 3.5 million from July through September.
# Monthly trips YoY plot
gg_monthly_trips <- monthly_trips %>%
ggplot(aes(x = date_x, y = trips, fill = as.character(year))) +
geom_bar(stat = "identity", color = "black",
position = position_dodge(width = 25), width = 20) +
scale_x_date(date_breaks = "1 month", date_labels = "%b") +
scale_y_continuous(labels = comma) +
labs(title = paste0("Trips per Month declined significantly in March,\nbottoming out at 1.5 million in April"),
x = "Month", y = "Trips",
fill = "Year") +
scale_fill_ipsum() +
theme_ipsum()
# Interactive plot
ggplotly(gg_monthly_trips)
It is clear that behavior changed in March even before the Stay-at-Home Order, as trips per day decreased significantly after Saturday, March 14th, 2020, a full week before the Order went into effect.
# Trips per day YoY plot
gg_trips_per_day <- daily_trips %>%
filter(month(date, label = TRUE) %in% c("Feb", "Mar")) %>%
group_by(year) %>%
arrange(date_x) %>%
ggplot(aes(x = date_x, y = trips, color = as.character(year))) +
geom_line(size = 1.5) +
geom_vline(xintercept = as.numeric(as.Date("2000-03-21")),
linetype = 4, color = "black", size = 1) +
scale_x_date(date_breaks = "1 week",
date_labels = "%b-%d") +
scale_y_continuous(labels = comma,
limits = c(0, NA)) +
labs(title = paste0("Trips per Day fell before the Stay-at-Home Order went into effect,\n peaking at 360,000 trips on Saturday, March 14th, 2020"),
x = "Day of the Year", y = "Trips per Day",
color = "Year") +
scale_color_ipsum() +
theme_ipsum()
# Interactive plot
ggplotly(gg_trips_per_day)
# Day of week YoY plot
# Pre/Post COVID table
gg_day_of_week_trips <- daily_trips %>%
mutate("covid_group" = ifelse(date_x >= "2000-03-21", "Post-COVID", "Pre-COVID")) %>%
mutate("covid_group" = factor(covid_group,
levels = c("Pre-COVID", "Post-COVID"))) %>%
group_by(covid_group, year, weekday) %>%
summarize(trips = sum(trips)) %>%
ungroup() %>%
ggplot(aes(x = weekday, y = trips, fill = as.character(year))) +
geom_bar(stat = "identity", color = "black") +
# scale_x_date(date_breaks = "1 month", date_labels = "%b") +
scale_y_continuous(labels = comma) +
labs(title = paste0("Trips per Day of Week, Pre/Post-COVID"),
x = "Month", y = "Trips",
fill = "Year") +
facet_grid(covid_group ~ year) +
scale_fill_ipsum() +
theme_ipsum()
# Interactive plot
ggplotly(gg_day_of_week_trips)
# Import data
trip_chars_avg <- dbGetQuery(con, "SELECT * FROM analysis.tnp_trip_chars") %>%
mutate("covid_group" = factor(covid_group,
levels = c("Pre-COVID", "Post-COVID")),
"trips" = as.numeric(trips)) %>%
arrange(covid_group, year)
Average distance of trips in miles:
# Average distance
# Pre/Post COVID table
trip_chars_avg %>%
select(covid_group, year, trip_miles) %>%
pivot_wider(names_from = "year",
values_from = "trip_miles") %>%
mutate("change" = `2020`-`2019`,
"change_pct" = (change/`2019`)) %>%
mutate(across(c(`2019`, `2020`, change), comma),
"change_pct" = percent(change_pct)) %>%
select("Period" = covid_group, `2019`, `2020`,
"Change" = change, "Change (%)" = change_pct) %>%
kbl() %>%
kable_styling(bootstrap_options = c("striped", "hover",
"condensed", "responsive"))
| Period | 2019 | 2020 | Change | Change (%) |
|---|---|---|---|---|
| Pre-COVID | 5.86 | 6.394 | 0.53 | 9.0% |
| Post-COVID | 6.36 | 6.486 | 0.13 | 2.1% |
Average time of trips in minutes:
# Average time - minutes
# Pre/Post COVID table
trip_chars_avg %>%
mutate("trip_minutes" = trip_seconds / 60) %>%
select(covid_group, year, trip_minutes) %>%
pivot_wider(names_from = "year",
values_from = "trip_minutes") %>%
mutate("change" = `2020`-`2019`,
"change_pct" = (change/`2019`)) %>%
mutate(across(c(`2019`, `2020`, change), comma),
"change_pct" = percent(change_pct)) %>%
select("Period" = covid_group, `2019`, `2020`,
"Change" = change, "Change (%)" = change_pct) %>%
kbl() %>%
kable_styling(bootstrap_options = c("striped", "hover",
"condensed", "responsive"))
| Period | 2019 | 2020 | Change | Change (%) |
|---|---|---|---|---|
| Pre-COVID | 17.5 | 16.9 | -0.6 | -3% |
| Post-COVID | 18.8 | 15.8 | -3.0 | -16% |
# Import data
fares <- dbGetQuery(con, "SELECT * FROM analysis.tnp_fares") %>%
mutate("covid_group" = factor(covid_group,
levels = c("Pre-COVID", "Post-COVID")),
"trips" = as.numeric(trips))
# Distribution of fares
fares_pct <- fares %>%
group_by(covid_group, year) %>%
arrange(year, covid_group, fare) %>%
mutate("trips_pct" = trips / sum(trips),
"trips_pct_agg" = cumsum(trips_pct)) %>%
ungroup()
# 95% of trips in all periods <$30 dollars
fares_tail <- fares_pct %>%
group_by(covid_group, year) %>%
filter(trips_pct_agg < 0.95) %>%
arrange(desc(fare)) %>%
slice(1) %>%
ungroup()
# Average fares
# Pre/Post COVID table
trip_chars_avg %>%
select(covid_group, year, fare) %>%
pivot_wider(names_from = "year",
values_from = "fare") %>%
mutate("change" = `2020`-`2019`,
"change_pct" = (change/`2019`)) %>%
mutate(across(c(`2019`, `2020`, change), dollar),
"change_pct" = percent(change_pct)) %>%
select("Period" = covid_group, `2019`, `2020`,
"Change" = change, "Change (%)" = change_pct) %>%
kbl() %>%
kable_styling(bootstrap_options = c("striped", "hover",
"condensed", "responsive"))
| Period | 2019 | 2020 | Change | Change (%) |
|---|---|---|---|---|
| Pre-COVID | $10.79 | $11.59 | $0.80 | 7.4% |
| Post-COVID | $12.35 | $12.22 | -$0.12 | -1.0% |
# Histogram
gg_fares <- fares %>%
ggplot(aes(x = fare, y = trips, fill = as.character(year))) +
geom_bar(stat = "identity", color = "black") +
geom_vline(data = trip_chars_avg,
mapping = aes(xintercept = fare),
linetype = "dashed", size = 1) +
scale_x_continuous(labels = dollar_format(prefix = "$"),
limits = c(0, max(fares_tail$fare))) +
scale_y_continuous(labels = comma) +
labs(title = paste0("Fare Distribution, Pre/Post-COVID"),
subtitle = "95% of trip fares were less than $30 in each period",
x = "Fare", y = "Trips",
fill = "Year") +
facet_grid(covid_group ~ year) +
scale_fill_ipsum() +
theme_ipsum()
# Interactive plot
ggplotly(gg_fares)
# Import data
origin_tracts_comp <- dbGetQuery(con, "SELECT * FROM analysis.pickup_tracts_comp")
sf_tracts <- st_read(con, layer = "spatial_tracts")
# Join tabular to spatial, reconfigure
origin_tracts_comp <- left_join(sf_tracts %>% select(GEOID),
origin_tracts_comp,
by = c("GEOID" = "pickup_census_tract")) %>%
st_as_sf() %>%
mutate("trips" = as.numeric(trips),
"covid_group" = factor(covid_group,
levels = c("Pre-COVID", "Post-COVID"))) %>%
arrange(covid_group, GEOID)
In the Pre-COVID period (1/1-3/21) the spatial distribution of rideshare pickups in 2019 and 2020 were very similar. After the Stay-at-Home Order went into effect, however, trips cratered, particularly those originating on the South, West, and Northwest Sides. Even the core area of high trip activity, roughly comprising the Loop and the North Side, shrunk in size.
# Map
# origin_tracts_comp %>%
# ggplot(aes(fill = trips)) +
# facet_wrap(~year) +
# geom_sf(color = "light gray") +
# coord_sf(crs = 4326) +
# scale_fill_viridis_c(labels = comma) +
# labs(title = "Rideshare Trips by Origin Census Tract") +
# theme_ipsum()
# Quantile map
tm_shape(origin_tracts_comp) +
tm_fill(col = "trips", title = "Trips",
style = "quantile", palette = "viridis") +
tm_borders() +
tm_facets(by = c("covid_group", "year"),
free.coords = FALSE,
drop.units = TRUE) +
tm_layout(main.title = "Rideshare Trips by Origin Census Tract",
main.title.position = c("center"),
legend.outside = FALSE,
legend.position = c("left", "bottom"))
# Import data
destination_tracts_comp <- dbGetQuery(con, "SELECT * FROM analysis.dropoff_tracts_comp")
# Join tabular to spatial, reconfigure
destination_tracts_comp <- left_join(sf_tracts %>% select(GEOID),
destination_tracts_comp,
by = c("GEOID" = "dropoff_census_tract")) %>%
st_as_sf() %>%
mutate("trips" = as.numeric(trips),
"covid_group" = factor(covid_group,
levels = c("Pre-COVID",
"Post-COVID"))) %>%
arrange(covid_group, GEOID)
# Map
# destination_tracts_comp %>%
# ggplot(aes(fill = trips)) +
# facet_wrap(~year) +
# geom_sf(color = "light gray") +
# coord_sf(crs = 4326) +
# scale_fill_viridis_c(labels = comma) +
# labs(title = "Rideshare Trips by Destination Census Tract") +
# theme_ipsum()
# Quantile map
tm_shape(destination_tracts_comp) +
tm_fill(col = "trips", title = "Trips",
style = "quantile", palette = "viridis") +
tm_borders() +
tm_facets(by = c("covid_group", "year"),
free.coords = FALSE,
drop.units = TRUE) +
tm_layout(main.title = "Rideshare Trips by Destination Census Tract",
main.title.position = c("center"),
legend.outside = FALSE,
legend.position = c("left", "bottom"))
# Import data
od_pairs_raw <- dbGetQuery(con, "SELECT * FROM analysis.trip_patterns_tracts_comp") %>%
mutate("covid_group" = factor(covid_group,
levels = c("Pre-COVID", "Post-COVID")),
"trips" = as.numeric(trips))
# Intra- vs inter-tract pairs
od_pairs_intra_inter <- od_pairs_raw %>%
mutate("intra_inter" = case_when(pickup_census_tract ==
dropoff_census_tract ~
"Intra (Within Same Tract)",
pickup_census_tract !=
dropoff_census_tract ~
"Inter (Different Tract)")) %>%
group_by(covid_group, year, intra_inter) %>%
summarize("trips" = sum(trips)) %>%
ungroup()
# Remove intra-tract trips, make sure in Chicago
# reorganize columns to convert to desire lines
od_pairs_comp <- od_pairs_raw %>%
filter(pickup_census_tract != dropoff_census_tract,
pickup_census_tract %in% sf_tracts$GEOID,
dropoff_census_tract %in% sf_tracts$GEOID) %>%
select(pickup_census_tract, dropoff_census_tract,
everything()) %>%
od2line(flow = ., zones = sf_tracts)
## Creating centroids representing desire line start and end points.
# Create a linewidth variable to scale desire lines
od_pairs_comp <- od_pairs_comp %>%
mutate("lwd" = trips / mean(od_pairs_comp$trips)) %>%
relocate(lwd, .after = trips)
Before analyzing trip flows, it is important to distinguish between those trips that begin and end within the same tract (intra-flows) and trips that begin and end in different tracts (inter-flows). As seen in the table below, very few rideshare trips started and ended in the same tract. About 1.5% of all trips were intra-flows. This was relatively consistent across years and time periods.
# OD Pairs Intra vs Inter
# Pre/Post-COVID table
od_pairs_intra_inter %>%
pivot_wider(names_from = c("year", "covid_group"),
values_from = "trips") %>%
adorn_totals(c("row", "col")) %>%
adorn_percentages("col") %>%
adorn_pct_formatting() %>%
kbl(col.names = c("Trip Type", "2019", "2020",
"2019", "2020", "Total")) %>%
add_header_above(c(" ", "Pre-COVID" = 2, "Post-COVID" = 2, " ")) %>%
row_spec(3, bold = TRUE) %>%
kable_styling(bootstrap_options = c("striped", "hover",
"condensed", "responsive"))
| Trip Type | 2019 | 2020 | 2019 | 2020 | Total |
|---|---|---|---|---|---|
| Inter (Different Tract) | 98.2% | 98.4% | 98.7% | 98.1% | 98.5% |
| Intra (Within Same Tract) | 1.8% | 1.6% | 1.3% | 1.9% | 1.5% |
| Total | 100.0% | 100.0% | 100.0% | 100.0% | 100.0% |
# Distribution of OD trip pairs
od_pairs_pct <- od_pairs_comp %>%
st_drop_geometry() %>%
group_by(covid_group, year) %>%
arrange(year, covid_group, desc(trips)) %>%
mutate("trips_pct" = trips / sum(trips),
"trips_pct_agg" = cumsum(trips_pct)) %>%
ungroup()
# 90% of OD trip pairs in all periods >10 trips
od_pairs_tail <- od_pairs_pct %>%
group_by(covid_group, year) %>%
filter(trips_pct_agg < 0.90) %>%
arrange(trips) %>%
slice(1) %>%
ungroup()
# OD flows map (all tracts)
tmap_od_all <- tm_shape(sf_tracts) +
tm_borders() +
tm_shape(od_pairs_comp %>%
filter(trips >= 1000)) +
tm_lines(col = "trips", title = "Trips",
style = "quantile", palette = "viridis",
lwd = "lwd", title.lwd = "Trips",
scale = 50, alpha = 0.5,
legend.lwd.show = FALSE) +
tm_facets(by = c("covid_group", "year"),
free.coords = FALSE,
drop.units = TRUE) +
tm_layout(main.title = "Rideshare Trips by Origin-Destination (OD) Pairs\nOD Pairs with 1,000+ Trips",
main.title.position = c("center"),
legend.outside = FALSE,
legend.position = c("left", "bottom"),
asp = 1.5)
tmap_od_all
# OD flows map (excluding airports - GEOIDs 17031980000, )
tmap_od_subset <- tm_shape(sf_tracts) +
tm_borders() +
tm_shape(od_pairs_comp %>%
filter(trips >= 1000,
!pickup_census_tract %in% c("17031980000",
"17031980100"),
!dropoff_census_tract %in% c("17031980000",
"17031980100"),)) +
tm_lines(col = "trips", title = "Trips",
style = "quantile", palette = "viridis",
lwd = "lwd", title.lwd = "Trips",
scale = 100, alpha = 0.5,
legend.lwd.show = FALSE) +
tm_facets(by = c("covid_group", "year"),
free.coords = FALSE,
drop.units = TRUE) +
tm_layout(main.title = "Rideshare Trips by Origin-Destination (OD) Pairs\nOD Pairs with 1,000+ Trips\nExcluding O'Hare, Midway Airports",
main.title.position = c("center"),
legend.outside = FALSE,
legend.position = c("left", "bottom"),
asp = 1.5)
tmap_od_subset